home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 February: Tool Chest / Apple Developer CD Series Tool Chest February 1996 (Apple Computer)(1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / zebu v3.3.3 (LALR parser) / zebu-aux.lisp < prev    next >
Encoding:
Text File  |  1994-09-12  |  9.8 KB  |  271 lines  |  [TEXT/ttxt]
  1. ; -*- mode:     CL -*- ----------------------------------------------------- ;
  2. ; File:         zebu-aux.lisp
  3. ; Description:  Functions and structures common to compiler and driver
  4. ; Author:       Joachim H. Laubsch
  5. ; Created:      11-Oct-90
  6. ; Modified:     Tue Aug  2 17:51:33 1994 (Joachim H. Laubsch)
  7. ; Language:     CL
  8. ; Package:      ZEBU
  9. ; Status:       Experimental (Do Not Distribute) 
  10. ; RCS $Header: $
  11. ;
  12. ; (c) Copyright 1990, Hewlett-Packard Company
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; Revisions:
  15. ; RCS $Log: $
  16. ;  7-Apr-92 (Joachim H. Laubsch)
  17. ;  many efficiency improvements throughout based on using Lucid's monitor
  18. ;  facility.
  19. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20. (in-package "ZEBU")
  21. (provide "zebu-aux")
  22. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  23. ;;                                 for PSGRAPH
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25.  
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27. ;;                                   Version
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29. ;; The Version is determined at compile-time from a file named "Version"
  30.  
  31. #-MCL
  32. (defconstant *zebu-version*
  33.   #.(let (*default-pathname-defaults*)
  34.        (with-open-file (s (make-pathname
  35.                :name "Version"
  36.                :directory (pathname-directory *ZEBU-directory*))
  37.               :direction :input)
  38.      (read-line s)))
  39.   ) 
  40.  
  41. #+MCL
  42. (defconstant *zebu-version*
  43.   #.(with-open-file (s (make-pathname
  44.                         :name "Version"
  45.                         :directory (pathname-directory *ZEBU-directory*))
  46.                        :direction :input)
  47.       (read-line s)))
  48.  
  49. #-LUCID (declaim (special *load-source-pathname-types* 
  50.                           *load-binary-pathname-types*))
  51. #+(or MCL Allegro)
  52. (setq *load-source-pathname-types* '("lisp" NIL)
  53.       *load-binary-pathname-types* '("fasl"))
  54.  
  55. #+(and :SUN :LUCID)
  56. (setq *load-binary-pathname-types* '("sbin"))
  57.  
  58. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  59. ;;          Global Variables (shared by runtime system and compiler)
  60. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  61.  
  62. #-LUCID 
  63. (defvar *KEYWORD-PACKAGE* (find-package "KEYWORD"))
  64.  
  65. (defvar *generate-domain* t
  66.   "If true while Zebu compiling a grammar, generate the hierarchy
  67. otherwise the domain-hierarchy is written by the user.")
  68.  
  69. (defvar *ZEBU-PACKAGE* (find-package "ZEBU"))
  70.  
  71. (defvar *open-categories* '("IDENTIFIER" "NUMBER" "STRING"))
  72.  
  73. (proclaim '(special *NULL-Grammar*))
  74.  
  75. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  76. ;;                  Functions common to runtime and compiler
  77. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  78.  
  79. (defun list->vector (l)
  80.   (let* ((len (length l))
  81.      (v (make-sequence 'vector len)))
  82.     (declare (vector v))
  83.     (dotimes (i len v)
  84.       (setf (svref v i) (pop l)))))
  85.  
  86. (deftype IDENTIFIER  () '(and symbol (not null)))
  87.  
  88. (defun identifierp (x)
  89.   (typep x 'IDENTIFIER))
  90.  
  91. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  92. ;;          Lexical analysis (regex) Run/Compile time data structures
  93. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  94. ;;;
  95. ;;; Declare the global variables for storing the paren index list.
  96. ;;;
  97. (defvar *regex-groups* (make-array 10))
  98. (defvar *regex-groupings* 0)
  99.  
  100. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  101. ;;                     External representation
  102. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  103.  
  104. (defvar *zb-rules*)                     ; alist of rule-names and zb-rule structs
  105.  
  106. (defstruct zb-rule
  107.   -name
  108.   -productions)
  109. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  110. ;;                   Internal Representation of Productions
  111. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  112. ;;; About the internal representation of productions:
  113. ;;;  production-index:  (0 .. Number of productions - 1)
  114. ;;;  lhs:               a g-symbol
  115. ;;;  rhs:               a list of g-symbols
  116. ;;;  production-length: the length of rhs
  117.  
  118. (defstruct (production (:conc-name nil))
  119.   lhs
  120.   rhs
  121.   production-index
  122.   production-length)
  123.  
  124. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  125. ;;                   check the first form of a grammar file
  126. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  127. ;; this applies to a .zb as well as a .tab file
  128.  
  129. (declaim (special *compiler-grammar* *identifier-continue-chars*
  130.               *identifier-start-chars*))
  131.  
  132. (defun check-grammar-options (options filename compiling
  133.                       &aux g-name compiler?)
  134.   ;; check the list of options for plausibility
  135.   ;; on package conflict, Nil is returned to catch point: read-grammar-options
  136.   ;; we must then read the options again with *package* set correctly
  137.   (unless (and (listp options) (not (null options)))
  138.     (error "~S is not a valid Options List for a Zebu grammar!" options))
  139.   (flet ((wrng-make-grammar-arglist (key)
  140.        (error "~S is not a defined keyword for make-grammar." key)))
  141.     (do ((gg options (cddr gg))) ((null gg))
  142.       (let ((key (car gg)) (val (cadr gg)))
  143.     (if (keywordp key)
  144.         (case key
  145.           (:NAME    (setq g-name val))
  146.           (:PACKAGE
  147.            (let ((p (find-package val)))
  148.          (if p
  149.              (progn
  150.                (use-package "ZEBU" p)
  151.                (unless (eq *package* p)
  152.              (setq *package* p)
  153.              (throw 'read-grammar-options nil)))
  154.            (error
  155.             "Package ~s should be defined before ~:[loading~;compiling~] ~S"
  156.             val compiling filename))))
  157.           (:GRAMMAR (let ((g (find-grammar val)))
  158.               (setq compiler? t)
  159.               (if g
  160.                   (setq *compiler-grammar* g)
  161.                 (warn "Grammar ~S is not loaded" val))))
  162.           (:IDENTIFIER-CONTINUE-CHARS
  163.            (setf *identifier-continue-chars* val))
  164.           (:IDENTIFIER-START-CHARS
  165.            (setf *identifier-start-chars* val))
  166.           ((:STRING-DELIMITER :SYMBOL-DELIMITER :FILE :DOMAIN
  167.                   :LEX-CATS :WHITE-SPACE :DOMAIN-FILE
  168.                   :INTERN-IDENTIFIER :CASE-SENSITIVE))
  169.           (t (wrng-make-grammar-arglist key)))
  170.       (wrng-make-grammar-arglist key))))
  171.     (unless g-name
  172.       (setq g-name (pathname-name filename)
  173.         options (list* ':NAME g-name options)))
  174.     (unless compiler?
  175.       (warn "Compiling with :GRAMMAR \"null-grammar\".
  176. To use the meta grammar use: :GRAMMAR \"zebu-mg\" in options list!")
  177.       (setq *compiler-grammar* *NULL-Grammar*))
  178.     (when compiling
  179.       (setq options (list* ':FILE (namestring filename) options)))
  180.     options))
  181.  
  182. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  183. ;;                      The Root of the Domain Hierarchy
  184. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  185. (defstruct (kb-domain (:constructor nil)))
  186.  
  187. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  188. ;;          Internal representation of the domain hierarchy as a tree
  189. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  190.  
  191. (defstruct (type-tree-node
  192.          (:print-function
  193.           (lambda (item stream level)
  194.             (declare (ignore level))
  195.             (format stream "[[~s]]"
  196.                 (type-tree-node--label item)))))
  197.   -label
  198.   -subtypes
  199.   -supertype                ; back link
  200.   -slots
  201.   )
  202.  
  203. (defvar *domain-type-hierarchy*)    ; a backlinked tree
  204. (defvar *domain-HT* (make-hash-table))    ; a dictionary label --> node
  205.  
  206. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  207. ;;                        Map Domain def into Hashtable
  208. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  209. (declaim (special *domain-HT* *open-categories*))
  210. (defvar *lex-cats* nil)
  211. ;----------------------------------------------------------------------------;
  212. ; prepare-domain
  213. ;---------------
  214. ; convert a domain D (as read from a grammar file) into the tree representation
  215. ; 
  216. (defun prepare-domain (domain)
  217.   (clrhash *domain-HT*)
  218.   (let* ((top (new-domain-node ':TOP nil nil)))
  219.     (setf *domain-type-hierarchy* top
  220.       (type-tree-node--subtypes top)
  221.       (list*
  222.        (new-domain-node 'kb-sequence top '(first rest))
  223.        (new-domain-node 'kb-domain top '())
  224.        (nconc (mapcar #'(lambda (s)
  225.                   (new-domain-node (intern s) top nil))
  226.               *open-categories*)
  227.           (mapcar #'(lambda (c) (new-domain-node (car c) top nil))
  228.               *lex-cats*))))
  229.     (when domain
  230.       (add-to-domain domain top)
  231.       domain)))
  232.  
  233. (defun add-to-domain (node point)
  234.   (if (consp node)
  235.       (let* ((label (car node))
  236.          (slots (cadr (member ':slots node)))
  237.          (new-point (new-domain-node label point slots)))
  238.     (push new-point (type-tree-node--subtypes point))
  239.     (do ((args (cdr node) (cddr args)))
  240.         ((null args))
  241.       (when (eq (car args) ':subtype)
  242.         (add-to-domain (cadr args) new-point))))
  243.     (let ((new-point (new-domain-node node point nil)))
  244.       (push new-point (type-tree-node--subtypes point)))))
  245.  
  246. (defun new-domain-node (label supertype slots)
  247.   (let ((new (make-type-tree-node
  248.           :-label label :-supertype supertype :-slots slots)))
  249.     (setf (gethash label *domain-HT*) new)))
  250.  
  251. #||
  252. (prepare-domain '(cl-user::arith-exp
  253.           :subtype (cl-user::factor :slots (-value))
  254.           :subtype (cl-user::*-op   :slots (-arg1 -arg2))
  255.           :subtype (cl-user::+-op   :slots (-arg1 -arg2))
  256.           :subtype (cl-user::expression :slots (-value))))
  257. ||#
  258.  
  259. (defun def-kb-domain-type (type super slots)
  260.   (let*  ((super-nd (or (gethash super *domain-HT*)
  261.             (new-domain-node
  262.              super (gethash ':top *domain-HT*) '())))    
  263.       (type-nd (or (gethash type *domain-HT*)
  264.                (new-domain-node type super-nd slots))))
  265.     (pushnew type-nd (type-tree-node--subtypes super-nd))
  266.     type-nd))
  267.  
  268. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  269. ;;                           End of zebu-aux.lisp
  270. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  271.